home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / RULES / Rule-Browser.lisp < prev    next >
Encoding:
Text File  |  1990-06-25  |  36.9 KB  |  811 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         Rule-Browser.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      04-Nov-88 13:58:46
  17. ; Modified:     22-Jun-90 02:22:42 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      RULE
  20. ;
  21. ; Description:  Loads and saves rules; Graphs justification trees for rule 
  22. ;               traces. 
  23. ;
  24. ; (c) Copyright 1988, by Daniel D. Suthers
  25. ;                        Department of Computer and Information Science
  26. ;                        University of Massachusetts
  27. ;                        Amherst, Massachusetts 01003
  28. ;
  29. ; This software was conceived, designed, and written by Dan Suthers 
  30. ; while supported by the National Science Foundation under grant number
  31. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  32. ; CA.  Partial support was also received from the Office of Naval Research
  33. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  34. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  35. ; the above grants and encouraged me to pursue my own research interests in
  36. ; her lab.  This work would not have been possible without the resources and
  37. ; stimulating environment of the Computer and Information Science department.
  38. ;
  39. ; Permission to use, modify, and distribute this software is granted subject 
  40. ; to the following restrictions and understandings:
  41. ; 1. The file header, including this notice, shall be retained, and may be
  42. ;    extended to include documentation of modifications to the software.
  43. ; 2. This material is for nonprofit educational and research purposes only.
  44. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  45. ;    noteworthy uses of this software.
  46. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  47. ;    representation that the operation of this software will be error free,
  48. ;    and are under no obligation to provide any services.
  49. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  50. ;    Suthers and the University of Massachusetts from all claims arising 
  51. ;    out of the use or misuse of this software, or arising out of any 
  52. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  53. ;    fees, and liabilities incurred in or about any such claim, action, or
  54. ;    proceeding brought thereon.
  55. ; 5. All materials and reports developed as a consequence of the use of 
  56. ;    this software shall duly acknowledge such use, in accordance with
  57. ;    the usual standards of acknowledging credit in academic research.
  58. ;
  59. ; Status: Appears to be working.
  60. ;
  61. ; Changes:      
  62. ;   26-Dec-88 Adjusting labels.
  63. ;   06-Apr-89 Trace indentation; updated for new :lisp and :asserted nodes.
  64. ;   07-Nov-89 Wrote menu-item-update for trace-rules item.
  65. ;   30-Jan-90 Updated for version 1.3.1.
  66. ;
  67. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68.  
  69. (in-package :RULE)
  70.  
  71. (require :MISC)
  72. (require :Rule-Defs)
  73. ;;; take our chances on the others.  Don't know if they are doing forward or back.
  74. (require :Grapher)
  75.  
  76. (export '(
  77.           *rule-trace-window*
  78.           graph-support-tree
  79.           ))
  80.  
  81. (use-package :DNET)
  82.  
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84.  
  85. (defconstant PREDEFINED-WARRANTS '(:and :seq :or :asserted :bind :lisp))
  86.  
  87. (defparameter *MIN-GRAPH-NODE-WIDTH* 12) ; 12 = |unsupported|
  88. (defparameter *MAX-GRAPH-NODE-WIDTH* 25)
  89.  
  90. (defun LABEL-STRING (object-to-print lower-bound upper-bound)
  91.   ;; Returns string version of <object-to-print> which is within the
  92.   ;; bounds, and truncated or centered as needed.
  93.   (let* ((object-string (format nil "~S" object-to-print))
  94.          (string-length (length object-string))
  95.          (string-of-spaces 
  96.           "                                                                      "))
  97.     (declare (string object-string) (fixnum string-length))
  98.     (cond 
  99.      ((> string-length upper-bound)
  100.       (setq object-string (subseq object-string 0 upper-bound))
  101.       (setf (subseq object-string (- upper-bound 3) upper-bound) "...")
  102.       object-string)
  103.      ((>= string-length lower-bound) object-string)
  104.      (T
  105.       (let ((half-the-difference (/ (- lower-bound string-length) 2)))
  106.         (declare (float half-the-difference))
  107.         (concatenate 'string
  108.                      (subseq string-of-spaces 0 (floor   half-the-difference))
  109.                      object-string
  110.                      (subseq string-of-spaces 0 (ceiling half-the-difference))))))))
  111.  
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113.  
  114. (defparameter *RULE-TRACE-WINDOW*
  115.   (ccl:oneof ccl:*fred-window*
  116.              :window-title "Rule Trace"
  117.              :window-position (ccl:make-point 2 337)
  118.              :window-size     (ccl:make-point 635 140)
  119.              :window-font '("monaco" 9)
  120.              :window-type :document-with-zoom
  121.              :close-box-p nil
  122.              :scratch-p T))
  123. (ccl:ask *rule-trace-window* (ccl:window-hide))
  124.  
  125. (defmacro RULE-TRACE (template &rest args)
  126.   ;; Works like format, but prints to rule trace window, and updates position.
  127.   `(progn 
  128.      (let ((trace-buffer (ccl:ask *rule-trace-window* (ccl:window-buffer))))
  129.        ;; Write in the new trace (T means end of buffer)
  130.        (ccl:buffer-insert trace-buffer (format nil ,template ,@args) T)
  131.        ;; Move the window so the new material can be seen.
  132.        (ccl:ask 
  133.         *rule-trace-window*
  134.         (ccl:set-mark (ccl:window-start-mark)
  135.                       (ccl:buffer-line-start trace-buffer T -10))
  136.       (ccl:window-update)))))
  137.  
  138. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  139.  
  140. (defparameter *SUPPORT-TREE-MOUSE-METHODS*
  141.   (append
  142.    (list
  143.  
  144.     (cons 
  145.      "Show Supported Bound Claims"
  146.      (compile 
  147.       nil
  148.       '(lambda (gw gv gn)
  149.          (declare (ignore gw gv))
  150.          (let ((trj-struct 
  151.                 (grapher:graph-node-object (sm:gets 'grapher:graph-node gn))))
  152.            (if (trj-node-p trj-struct)
  153.              (let ((*print-pretty* t)
  154.                    (claim (trj-node-claim trj-struct))
  155.                    (binding-sets (trj-node-bindings trj-struct)))
  156.                (ccl:ask *rule-trace-window*
  157.                         (unless (ccl:window-shown-p) (ccl:window-show))
  158.                         (unless (= (ccl:window-layer) 1) (ccl:set-window-layer 1)))
  159.                (cond 
  160.                 ;; There are variables bound: substitute bindings and show.
  161.                 (binding-sets 
  162.                  (rule-trace "~&---------- SUPPORTED BOUND CLAIMS at ~A:"
  163.                              (first (grapher:graph-node-label 
  164.                                      (sm:gets 'grapher:graph-node gn))))
  165.                  (dolist (binding-set binding-sets)
  166.                    (rule-trace "~%~A~%    Bindings: ~S"
  167.                                (utils:indent-string
  168.                                 (prin1-to-string 
  169.                                  (dnet:substitute-transitive-bindings binding-set 
  170.                                                                       claim))
  171.                                 2)
  172.                                binding-set)))
  173.                 ;; There are no bindings: just show the claim if supported.
  174.                 ((eq (trj-node-modality trj-struct) ':supported)
  175.                  (rule-trace "~&---------- SUPPORTED CLAIM AT ~A:~%~A"
  176.                              (first (grapher:graph-node-label 
  177.                                      (sm:gets 'grapher:graph-node gn)))
  178.                              (utils:indent-string (prin1-to-string claim) 2)))
  179.                 ;; It is unsupported.
  180.                 (t (rule-trace "~&---------- UNSUPPORTED CLAIM AT ~A:~%~A"
  181.                                (first (grapher:graph-node-label 
  182.                                        (sm:gets 'grapher:graph-node gn)))
  183.                                (utils:indent-string (prin1-to-string claim) 2)))))
  184.              (progn
  185.                (ccl:ed-beep)
  186.                (wind:message-dialogue 
  187.                 "I can only show the Claim of a TRJ Node, but you selected an Arc.")))))))
  188.  
  189.     (cons
  190.      "Show Unbound Claim"
  191.      (compile
  192.       nil
  193.       '(lambda (gw gv gn)
  194.          (declare (ignore gw gv))
  195.          (let ((trj-struct 
  196.                 (grapher:graph-node-object (sm:gets 'grapher:graph-node gn))))
  197.            (if (trj-node-p trj-struct)
  198.              (let ((*print-pretty* t))
  199.                (ccl:ask *rule-trace-window*
  200.                         (unless (ccl:window-shown-p) (ccl:window-show))
  201.                         (unless (= (ccl:window-layer) 1) (ccl:set-window-layer 1)))
  202.                    (rule-trace "~&---------- UNBOUND CLAIM at ~A:~%~A"
  203.                                (first (grapher:graph-node-label 
  204.                                        (sm:gets 'grapher:graph-node gn)))
  205.                                (utils:indent-string 
  206.                                 (prin1-to-string (trj-node-claim trj-struct))
  207.                                 2)))
  208.              (progn
  209.                (ccl:ed-beep)
  210.                (wind:message-dialogue 
  211.                 "I can only show the Claim of a TRJ Node, but you selected an Arc.")))))))
  212.  
  213.     (cons
  214.      "Show Arc Bindings"
  215.      (compile
  216.       nil
  217.       '(lambda (gw gv gn)
  218.          (declare (ignore gw gv))
  219.          (let ((trj-struct 
  220.                 (grapher:graph-node-object (sm:gets 'grapher:graph-node gn))))
  221.            (if (trj-arc-p trj-struct)
  222.              (let ((*print-pretty* t))
  223.                (ccl:ask *rule-trace-window*
  224.                         (unless (ccl:window-shown-p) (ccl:window-show))
  225.                         (unless (= (ccl:window-layer) 1) (ccl:set-window-layer 1)))
  226.                (rule-trace "~&---------- ARC BINDINGS at ~A: ~S"
  227.                            (grapher:graph-node-label (sm:gets 'grapher:graph-node gn))
  228.                            (trj-arc-bindings trj-struct)))
  229.              (progn
  230.                (ccl:ed-beep)
  231.                (wind:message-dialogue 
  232.                 "I can only show the Bindings of a TRJ Arc, but you selected a Node.")))))))
  233.  
  234.     (cons
  235.      "Make this Node the Root"
  236.      (compile
  237.       nil
  238.       '(lambda (gw gv gn)
  239.          (ccl:ask gw
  240.                   (let* ((gv-struct (sm:gets 'grapher:graph-view gv))
  241.                          (trj-struct (grapher:graph-node-object
  242.                                       (sm:gets 'grapher:graph-node gn)))
  243.                          (new-gv
  244.                           (if (trj-node-p trj-struct)
  245.                             (trj-node->graph-view 
  246.                              trj-struct
  247.                              (grapher:graph-view-style gv-struct)
  248.                              (grapher:graph-view-ordering gv-struct)
  249.                              (grapher:graph-view-depth-bound gv-struct)
  250.                              gv)))) ; parent view
  251.                     (when new-gv
  252.                       (grapher:set-graph-view new-gv)
  253.                       (ccl:set-window-title
  254.                        (label-string (trj-node-claim trj-struct) 10 40))
  255.                       (ccl:window-select)
  256.                       (ccl:view-draw-contents))
  257.                     (unless new-gv
  258.                       (ccl:ed-beep)
  259.                       (wind:message-dialogue 
  260.                        "I can't make a TRJ Arc the Root; Please select a TRJ Node.")
  261.                       ;; The graph-view of gw was set to nil since we 
  262.                       ;; thought gv was to be replaced ... restore it.
  263.                       (grapher:set-graph-view gv :layout nil)
  264.                       (ccl:view-draw-contents)))))))
  265.      
  266.     (cons
  267.      "Backup Once to Parent View"
  268.      (compile
  269.       nil
  270.       '(lambda (gw gv gn)
  271.          (declare (ignore gn))
  272.          (ccl:ask gw
  273.                   (let ((parent-view 
  274.                          (grapher:graph-view-info-image :parent-view gv)))
  275.                     (if parent-view
  276.                       (if (sm:gets 'grapher:graph-view parent-view)
  277.                         (progn
  278.                           (grapher:set-graph-view parent-view :layout nil)
  279.                           (ccl:set-window-title
  280.                            (label-string 
  281.                             (trj-node-claim
  282.                              (grapher:graph-view-info-image :original-root parent-view))
  283.                             10 40))
  284.                           (ccl:window-select)
  285.                           (ccl:view-draw-contents)
  286.                           (unless (grapher:windows-using-graph-view gv)
  287.                             (grapher:dispose-graph-view gv)))
  288.                         (progn (ccl:ed-beep)
  289.                                (setf (grapher:graph-view-info-image :parent-view gv) nil)
  290.                                (wind:message-dialogue 
  291.                                 "The parent view appears to have been destroyed.")
  292.                                ;; The graph-view of gw was set to nil since we 
  293.                                ;; thought gv was to be replaced ... restore it.
  294.                                (grapher:set-graph-view gv :layout nil)
  295.                                (ccl:view-draw-contents)))
  296.                       (progn (ccl:ed-beep)
  297.                              (wind:message-dialogue 
  298.                               "This graph view has no parent view.")
  299.                              (grapher:set-graph-view gv :layout nil)
  300.                              (ccl:view-draw-contents))))))))
  301.      
  302.     (cons
  303.      "Backup All the Way to Original View"
  304.      (compile
  305.       nil
  306.       '(lambda (gw gv gn)            
  307.          (declare (ignore gn))
  308.          (ccl:ask gw
  309.                   (let ((garbage-views nil) (original-view nil))
  310.                     ;; Search up to find original view; also recording the views
  311.                     ;; to be disposed of along the way. 
  312.                     (do* ((parent-view 
  313.                            (grapher:graph-view-info-image :parent-view gv)
  314.                            (grapher:graph-view-info-image :parent-view current-view))
  315.                           (current-view gv))
  316.                          ;; Invariant here: parent-view is parent of current-view,
  317.                          ;; so when parent-view nil, current-view is the root.
  318.                          ((null parent-view) (setq original-view current-view))
  319.                       (if (sm:gets 'grapher:graph-view parent-view)
  320.                         (progn
  321.                           (push current-view garbage-views)
  322.                           (setq current-view parent-view))
  323.                         (progn 
  324.                           (ccl:ed-beep)
  325.                           (setf (grapher:graph-view-info-image :parent-view current-view) nil)
  326.                           (wind:message-dialogue 
  327.                            "The parent of view ~A appears to have been destroyed."
  328.                            current-view)
  329.                           (setq parent-view nil)))) ; to exit
  330.                     (grapher:set-graph-view original-view :layout nil) ; already laid out
  331.                     (ccl:set-window-title 
  332.                      (label-string 
  333.                       (trj-node-claim
  334.                        (grapher:graph-view-info-image :original-root original-view))
  335.                       10 40))
  336.                     (ccl:window-select)
  337.                     (ccl:view-draw-contents)
  338.                     (dolist (ggv garbage-views)
  339.                       (unless (grapher:windows-using-graph-view ggv)
  340.                         (grapher:dispose-graph-view ggv))))))))
  341.  
  342.     (cons 
  343.      "New Window with this Node as Root"
  344.      (compile
  345.       nil
  346.       '(lambda (gw gv gn)
  347.          (let* ((gv-struct (sm:gets 'grapher:graph-view gv))
  348.                 (trj-struct (grapher:graph-node-object 
  349.                              (sm:gets 'grapher:graph-node gn)))
  350.                 (roots (list trj-struct))
  351.                 (style       (grapher:graph-view-style gv-struct))
  352.                 (ordering    (grapher:graph-view-ordering gv-struct))
  353.                 (depth-bound (grapher:graph-view-depth-bound gv-struct)))
  354.            (when (trj-node-p trj-struct)
  355.              (multiple-value-setq
  356.               (roots style ordering depth-bound)
  357.               (grapher:graph-view-parameter-dialogue
  358.                (label-string (trj-node-claim trj-struct) 10 40)
  359.                roots nil style ordering depth-bound))
  360.              (ccl:oneof
  361.               grapher:*graph-window* 
  362.               :window-title (label-string (trj-node-claim trj-struct) 10 40)
  363.               :graph-view
  364.               (trj-node->graph-view trj-struct style ordering depth-bound gv)))
  365.            (unless (trj-node-p trj-struct)
  366.              (ccl:ed-beep)
  367.              (wind:message-dialogue 
  368.               "I can't make a TRJ Arc the Root; Please select a TRJ Node."))))))
  369.  
  370. ;;; Put this back in when we add a mouse method for invoking the RBR to fill out
  371. ;;; a subtree.
  372. ;;;     ("Update Graph View for Changes"
  373. ;;;      . (lambda (gw gv gn)
  374. ;;;          (declare (ignore gn))
  375. ;;;          (let* ((gv-struct (sm:gets 'grapher:graph-view gv))
  376. ;;;                 (root (grapher:graph-view-info-image :original-root gv))
  377. ;;;                 (style       (grapher:graph-view-style gv-struct))
  378. ;;;                 (ordering    (grapher:graph-view-ordering gv-struct))
  379. ;;;                 (depth-bound (grapher:graph-view-depth-bound gv-struct))
  380. ;;;                 (parent-view (grapher:graph-view-info-image :parent-view gv))
  381. ;;;                 (new-view nil) (roots (list root)))
  382. ;;;            (multiple-value-setq
  383. ;;;             (roots style ordering depth-bound)
  384. ;;;             (grapher:graph-view-parameter-dialogue
  385. ;;;              root roots nil style ordering depth-bound))
  386. ;;;            (ccl:ask gw
  387. ;;;                     (grapher:set-graph-view nil)
  388. ;;;                     (setq new-view 
  389. ;;;                           (trj-node->graph-view 
  390. ;;;                            root style ordering depth-bound parent-view))
  391. ;;;                     (unless (grapher:windows-using-graph-view gv)
  392. ;;;                       (grapher:dispose-graph-view gv))
  393. ;;;                     (grapher:set-graph-view new-view)
  394. ;;;                     (ccl:set-window-title 
  395. ;;;  @@@ need to define TRJ-STRUCT (label-string (trj-node-claim trj-struct) 10 40))
  396. ;;;                     (ccl:window-select)
  397. ;;;                     (ccl:view-draw-contents)))))
  398.      
  399.     (cons
  400.      "Edit Associated Rule"
  401.      (compile
  402.       nil
  403.       '(lambda (gw gv gn)
  404.          (declare (ignore gw gv))
  405.          (let ((trj-object
  406.                 (grapher:graph-node-object (sm:gets 'grapher:graph-node gn))))
  407.            (if (trj-arc-p trj-object)
  408.              (let ((warrant (trj-arc-warrant trj-object)))
  409.                (cond ((member warrant predefined-warrants)
  410.                       (ccl:ed-beep)
  411.                       (wind:message-dialogue 
  412.                        "This is an ~S arc, which does not reference a rule."
  413.                        warrant))
  414.                      ((and (symbolp warrant) (sm:gets 'rule warrant))
  415.                       (sm:edits 'rule warrant))
  416.                      (T
  417.                       (ccl:ed-beep)
  418.                       (wind:message-dialogue "Rule ~S does not exist!" warrant))))
  419.              (progn 
  420.                (ccl:ed-beep)
  421.                (wind:message-dialogue
  422.                 "You selected a TRJ Node, but rules are only referenced by TRJ Arcs!")))))))
  423.  
  424.     )
  425.    ;; Note that SM stores unevaluated expressions producing defaults.
  426.    (eval
  427.     (cdr (assoc 'grapher::mouse-methods
  428.                 (sm:slot-defaults 'grapher:graph-view))))))
  429.  
  430. (defun GRAPH-SUPPORT-TREE (root-node &key (style :vertical-tree)
  431.                                    (ordering :as-found)
  432.                                    (depth-bound 6)
  433.                                    (window-size (ccl:make-point 635 280))
  434.                                    (window-position
  435.                                     (ccl:make-point 2 ccl:*menubar-bottom*))
  436.                                    &aux (roots (list root-node)))
  437.   "graph-support-tree <root-node> &key <style> <ordering> <depth-bound> 
  438.                    <window-size> <window-position>           [Function]
  439.   Graphs the tree of support below <root-node>, after asking user for 
  440.   graph parameters."
  441.   (check-type root-node   trj-node)
  442.   (check-type style       keyword)
  443.   (check-type ordering    keyword)
  444.   (check-type depth-bound fixnum)
  445.  
  446.   ;; Get desired parameters.
  447.   (multiple-value-setq
  448.    (roots style ordering depth-bound)
  449.    (grapher:graph-view-parameter-dialogue
  450.     (label-string (trj-node-claim root-node) 10 40)
  451.     roots nil style ordering depth-bound))
  452.  
  453.   ;; Graph and put up in window. Exist method handles layout, selecting, and drawing.
  454.   (ccl:oneof grapher:*graph-window*
  455.              :window-title    (label-string (trj-node-claim root-node) 10 40)
  456.              :window-size     window-size
  457.              :window-position window-position
  458.              :graph-view
  459.              (TRJ-NODE->graph-view root-node style ordering depth-bound nil)))
  460.  
  461. (defun TRJ-NODE->GRAPH-VIEW (root-node style ordering depth-bound parent-view)
  462.   (declare (trj-node root-node) (symbol parent-view) (keyword style ordering) 
  463.            (fixnum depth-bound))
  464.   (let ((graph-view-name
  465.          (utils:unique-symbol (label-string (trj-node-claim root-node) 10 40))))
  466.     (declare (symbol graph-view-name))
  467.     (grapher:create-graph-view
  468.      graph-view-name 
  469.      (list (graph-trj-node-subtree root-node depth-bound))
  470.      depth-bound style ordering
  471.      '("Geneva" 9) '("chicago" 12) 10
  472.      `((:parent-view . ,parent-view)  ; info
  473.        (:original-root . ,root-node))
  474.      *support-tree-mouse-methods*)))
  475.  
  476. (defun GRAPH-TRJ-NODE-SUBTREE (root-node depth-left)
  477.   ;; Constructs graphical tree of support, Returns top level graph node created.
  478.   (declare (trj-node root-node) (fixnum depth-left)
  479.            (optimize (safety 1) (space 2) (speed 3)))
  480.   
  481.   ;; Make a graph node labeled by claim and modality and branching
  482.   ;; on support via graphed trj-arcs to reach other trj-nodes.
  483.   (grapher:create-graph-node
  484.    (gensym)
  485.    ;; Labels.  Center the modality in wide nodes.
  486.    (let* ((claim-label (label-string (trj-node-claim root-node)
  487.                                     *min-graph-node-width*
  488.                                     *max-graph-node-width*))
  489.           (claim-label-length (length claim-label)))
  490.      (declare (string claim-label) (fixnum claim-label-length))
  491.      (list claim-label
  492.            (label-string (trj-node-modality root-node)
  493.                          (max *min-graph-node-width* claim-label-length)
  494.                          (min *max-graph-node-width* claim-label-length))))
  495.  
  496.    ;; Children
  497.    (mapcan #'(lambda (ta)
  498.                (declare (trj-arc ta))
  499.                (graph-trj-arc-subtree ta (1- depth-left)))
  500.            (trj-node-support root-node))
  501.    ;; Box style a function of whether there is a subtree (even if not shown).
  502.    (if (trj-node-support root-node) :round-frame :frame)
  503.    ;; Connector; Object
  504.    T root-node))
  505.  
  506. (defun GRAPH-TRJ-ARC-SUBTREE (root-arc depth-left)
  507.   ;; Constructs subtree below <root-arc>; Returns the graph node root for <root-arc>.
  508.   (declare (trj-arc root-arc) (fixnum depth-left)
  509.            (optimize (safety 1) (space 2) (speed 3)))
  510.  
  511.   (unless (= depth-left 0)
  512.     (case (trj-arc-warrant root-arc)
  513.       ((:asserted) (graph-trj-asserted-subtree root-arc))
  514.       ((:bind)     (graph-trj-bind-subtree root-arc))
  515.       (otherwise
  516.        (list 
  517.        (grapher:create-graph-node
  518.         (gensym)
  519.         ;; Label (could be :AND, :SEQ, :OR, or rule name, which may be long).
  520.         (label-string  (trj-arc-warrant root-arc) 1 *max-graph-node-width*)
  521.         ;; Children
  522.         (mapcar #'(lambda (tn)
  523.                     (declare (trj-node tn))
  524.                     (graph-trj-node-subtree tn depth-left)) ; only count node depth.
  525.                 (trj-arc-grounds root-arc))
  526.         ;; Box style 
  527.         :none
  528.         ;; Connector; Object
  529.         nil root-arc))))))
  530.  
  531. (defun GRAPH-TRJ-ASSERTED-SUBTREE (root-arc)
  532.   (declare (trj-arc root-arc) (fixnum depth-left)
  533.            (optimize (safety 1) (space 2) (speed 3)))
  534.   (list
  535.    (grapher:create-graph-node
  536.     ;; Name, Label
  537.     (gensym) "Asserted" 
  538.     ;; Children
  539.     (list 
  540.      (grapher:create-graph-node 
  541.       (gensym) 
  542.       ;; Bogus frame needed since mouse methods assume list label.
  543.       (list (label-string (trj-node-claim (first (trj-arc-grounds root-arc)))
  544.                           1 *max-graph-node-width*))
  545.       nil :frame T (first (trj-arc-grounds root-arc))))
  546.     ;; Box-Style, Connector, Object.
  547.     :none nil root-arc)))
  548.  
  549. (defun GRAPH-TRJ-BIND-SUBTREE (root-arc)
  550.   (declare (trj-arc root-arc) (fixnum depth-left)
  551.            (optimize (safety 1) (space 2) (speed 3)))
  552.   (list
  553.    (grapher:create-graph-node
  554.     ;; Name, Label, Children, Box-Style, Connector, Object.
  555.     (gensym) "Bind" nil :rect T root-arc)))
  556.  
  557. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  558.  
  559. (defparameter *RULE-MENU*
  560.   (let* ((line-item
  561.           (ccl:oneof ccl:*menu-item*
  562.                      :menu-item-title "-"))
  563.  
  564.          (graph-support-tree
  565.           (ccl:oneof 
  566.            ccl:*menu-item*
  567.            :menu-item-title "Graph Last Support Tree"
  568.            :menu-item-action
  569.            #'(lambda () 
  570.                (if (and (boundp '*support-tree*) (trj-node-p *support-tree*))
  571.                  (graph-support-tree *support-tree*)
  572.                  (progn 
  573.                    (ccl:ed-beep)
  574.                    (wind:message-dialogue
  575.                     "RULE:*SUPPORT-TREE* is not bound to a TRJ-NODE.  Call RULE:SUPPORT first."))))))
  576.  
  577.          (graph-support-for
  578.           (ccl:oneof 
  579.            ccl:*menu-item*
  580.            :menu-item-title "Graph Support For ..."
  581.            :menu-item-action
  582.            #'(lambda ()
  583.                (let ((goal
  584.                       (read-from-string 
  585.                        (wind:get-string-dialogue 
  586.                         "Graph support for what goal expression?")))
  587.                      (data-base
  588.                       (wind:menu-dialogue (sm:instances 'dnet:dnet)
  589.                                           "Use what DNET for the Data Base?"))
  590.                      (rule-base
  591.                       (wind:menu-dialogue (sm:instances 'dnet:dnet)
  592.                                           "Use what DNET for the Rule Base?"))
  593.                      (record-failure 
  594.                       (wind:y-or-n-dialogue "Graph failed attempts to support?")))
  595.                  (ccl:eval-enqueue
  596.                   `(multiple-value-bind 
  597.                      (success support-node)
  598.                      (support ',goal ',data-base ',rule-base 
  599.                               :record-failure ',record-failure)
  600.                      (cond (success (graph-support-tree support-node))
  601.                            (',record-failure (graph-support-tree support-node))
  602.                            (t (ccl:ed-beep)
  603.                               (wind:message-dialogue "~S was not supported." ',goal)))))))))
  604.          (trace-rules
  605.           (ccl:oneof 
  606.            ccl:*menu-item*
  607.            :menu-item-title "Trace Rules"
  608.            :menu-item-action
  609.            #'(lambda ()
  610.                (if *rule-trace*
  611.                  (setf *rule-trace* nil)
  612.                  (setf *rule-trace* *rule-trace-window*))
  613.                (if *rule-trace*
  614.                  (ccl:set-menu-item-check-mark t)
  615.                  (ccl:set-menu-item-check-mark nil)))))
  616.  
  617.          (show-rule-trace
  618.           (ccl:oneof 
  619.            ccl:*menu-item*
  620.            :menu-item-title "Show Rule Trace"
  621.            :menu-item-action
  622.            #'(lambda () 
  623.                (ccl:ask *rule-trace-window*
  624.                         (unless (ccl:window-shown-p) (ccl:window-show))
  625.                         (ccl:window-select)))))
  626.  
  627.          (hide-rule-trace
  628.           (ccl:oneof 
  629.            ccl:*menu-item*
  630.            :menu-item-title "Hide Rule Trace"
  631.            :menu-item-action
  632.            #'(lambda () (ccl:ask *rule-trace-window* 
  633.                                  (when (ccl:window-shown-p) (ccl:window-hide))))))
  634.  
  635.          (reset-item
  636.           (ccl:oneof 
  637.            ccl:*menu-item*
  638.            :menu-item-title "Reset Rules ..."
  639.            :menu-item-action
  640.            #'(lambda ()
  641.                (when (wind:y-or-n-dialogue 
  642.                       "Destroy all in-memory instances of type RULE? (Rule base DNETs will still be usable; you just can't edit them any more.)")
  643.                  (ccl:eval-enqueue 
  644.                   '(progn 
  645.                      (sm:destroy-sm-editor-windows-of-type 'rule :ask-user T)
  646.                      (sm:reset-type 'rule)))))))
  647.  
  648.          ;; This is here mainly for consistency, since we have Save Rules here.  But
  649.          ;; the user could use Save Type.
  650.          (load-item
  651.           (ccl:oneof 
  652.            ccl:*menu-item*
  653.            :menu-item-title "Load Rules ..."
  654.            :menu-item-action
  655.            #'(lambda ()
  656.                (let ((file-path
  657.                       (ccl:choose-file-dialog
  658.                        :directory
  659.                        (format nil "~A~A.~A"
  660.                                sm:*default-instance-file-path*
  661.                                'rule
  662.                                sm:*default-instance-file-type*))))
  663.                  (if (probe-file file-path)
  664.                    (progn
  665.                      ;; Change default path to one given, and record path
  666.                      (setf sm:*default-instance-file-path*
  667.                            (directory-namestring file-path))
  668.                      (ccl:eval-enqueue 
  669.                       `(progn (sm:load-type 'rule :path ',file-path)
  670.                               (add-all-rules))))
  671.                    (wind:message-dialogue 
  672.                     "File ~S doesn't seem to exist." (namestring file-path)))))))
  673.  
  674.          ;; We need a specialized Save Rules because we have to find all the variables
  675.          ;; in the rules and define them, using save-type's :init-forms argument.
  676.          ;; This code is modified from SMEDIT's Save Type menu item: see comments there.
  677.          (save-item
  678.           (ccl:oneof 
  679.            ccl:*menu-item*
  680.            :menu-item-title "Save Rules ..."
  681.            :menu-item-action
  682.            #'(lambda ()
  683.                (let* ((file-path
  684.                        (pathname
  685.                         (ccl:choose-new-file-dialog
  686.                          :directory
  687.                          (let ((prev-path (get 'rule 'sm::$SM-instance-path$)))
  688.                            (if prev-path
  689.                              (make-pathname 
  690.                               :device    (pathname-device prev-path)
  691.                               :directory (pathname-directory prev-path)
  692.                               :name      (pathname-name prev-path)
  693.                               :type      sm:*default-instance-file-type*)
  694.                              (make-pathname
  695.                               :directory sm:*default-instance-file-path*
  696.                               :name "RULE"
  697.                               :type      sm:*default-instance-file-type*)))
  698.                          :prompt (format nil "Save RULEs to ..."))))
  699.                       (backup-path
  700.                        (make-pathname
  701.                         :host      (pathname-host file-path)
  702.                         :device    (pathname-device file-path)
  703.                         :directory (pathname-directory file-path)
  704.                         :name      (pathname-name file-path)
  705.                         :type      "bak"))
  706.                       (instances (sm:instances 'rule)))
  707.                  (multiple-value-bind
  708.                    (compile-p define-type-p specify-instances append-p)
  709.                    (sm:save-type-parameter-dialogue 'rule)
  710.                    (if specify-instances
  711.                      (setf instances
  712.                            (if (wind:y-or-n-dialogue 
  713.                                 "Are the rules you want to save interned in a particular Rule Base (DNET)?")
  714.                              (let ((rule-bases nil) (rule-base nil) (rules nil))
  715.                                (dolist (r (sm:instances 'rule))
  716.                                  (dolist (rb (rule-interned-in (sm:gets 'rule r)))
  717.                                    (pushnew rb rule-bases)))
  718.                                (setf rule-base
  719.                                      (wind:menu-dialogue
  720.                                       rule-bases
  721.                                       "Save rules in which Rule Base?"))
  722.                                (dolist (r (sm:instances 'rule))
  723.                                  (if (member rule-base (rule-interned-in (sm:gets 'rule r)))
  724.                                    (push r rules)))
  725.                                rules)
  726.                              (wind:multiple-menu-dialogue
  727.                               instances
  728.                               "Choose the instances of RULE to save to ~S"
  729.                               (namestring file-path)))))
  730.                    (when (and (not append-p) (probe-file file-path))
  731.                      (if (probe-file backup-path) (delete-file backup-path))
  732.                      (rename-file file-path backup-path)
  733.                      (format T "~&;~A backed up to ~A" 
  734.                              (namestring file-path) (namestring backup-path)))
  735.                    (setf sm:*default-instance-file-path*
  736.                          (directory-namestring file-path))
  737.                    ;; Find the variables and cons up declarations for them.
  738.                    (let ((variable-names
  739.                           (sort
  740.                            (mapcar 
  741.                             #'symbol-name
  742.                             (delete-duplicates
  743.                              (reduce 
  744.                               #'nconc
  745.                               (mapcar 
  746.                                #'(lambda (r &aux (rstruct (sm:gets 'rule r)))
  747.                                    (append
  748.                                     (variables-in-pattern (rule-antecedent rstruct))
  749.                                     (variables-in-pattern (rule-consequent rstruct))))
  750.                                instances))))
  751.                            #'string<)))
  752.                      (sm:save-type 'rule
  753.                                    :path file-path
  754.                                    :style :pretty-macro
  755.                                    :compile nil
  756.                                    :define-type define-type-p
  757.                                    :instances instances
  758.                                    :init-forms (list (cons 'defvariables variable-names))
  759.                                    :append append-p)
  760.                      (format T "~&;Instances of RULEs saved to ~S"
  761.                              (namestring file-path))
  762.                      (if compile-p 
  763.                        (ccl:eval-enqueue `(compile-file ,(namestring file-path))))
  764.                      (unless specify-instances
  765.                        (ccl:eval-enqueue 
  766.                         '(sm:destroy-sm-editor-windows-of-type 'rule)))))))))
  767.  
  768.          (deinstall-item
  769.           (ccl:oneof ccl:*menu-item*
  770.                      :menu-item-title "Hide This Menu"
  771.                      :menu-item-action 
  772.                      '(ccl:ask *rule-menu* (ccl:menu-deinstall))))
  773.          (rule-menu (ccl:oneof ccl:*menu* 
  774.                                :menu-title "RULES"
  775.                                :menu-items (list graph-support-tree
  776.                                                  graph-support-for
  777.                                                  line-item
  778.                                                  trace-rules
  779.                                                  show-rule-trace
  780.                                                  hide-rule-trace
  781.                                                  line-item
  782.                                                  load-item
  783.                                                  save-item
  784.                                                  reset-item
  785.                                                  line-item
  786.                                                  deinstall-item))))
  787.     (ccl:defobfun (ccl:menu-item-update trace-rules) ()
  788.                   (if *rule-trace*
  789.                     (ccl:set-menu-item-check-mark t)
  790.                     (ccl:set-menu-item-check-mark nil)))
  791.     (ccl:ask rule-menu (ccl:menu-install))
  792.     (ccl:ask line-item (ccl:menu-item-disable))
  793.     ;; Menu-dispose dumped from version 1.3.1?
  794.     (if (and (boundp '*rule-menu*) 
  795.              (typep *rule-menu* ccl:*menu*))
  796.       (ccl:ask *rule-menu* (ccl:menu-deinstall)))
  797.     rule-menu))
  798.  
  799. (ccl:ask ccl:*tools-menu*
  800.   (ccl:add-menu-items
  801.    (ccl:oneof ccl:*menu-item*
  802.           :menu-item-title "Restore RULES Menu"
  803.           :menu-item-action
  804.           #'(lambda ()
  805.               (ccl:ask *rule-menu*
  806.                 (unless (ccl:menu-installed-p) (ccl:menu-install)))))))
  807.  
  808. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  809. (provide :Rule-Browser)
  810. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  811. ;;; the end.